Attribute VB_Name = "Debug"
Dim Logfile As String
Dim Stacklog As String
Dim fpath As String
Dim Setdebugbuild As Boolean
Dim Savefile As Boolean
Dim programon As Boolean

Dim Att As String 'Attentions
Dim Errors As String 'Errors
Dim Warnings As String 'Warnings
Dim Asserterror As String 'Failed asserts

Private Type subs
    name As String
    args As String
    time As Double
    notimes As Double
    sumtime As Double
End Type

Dim Callstack() As subs
Dim Callset As Boolean

Dim Timinglog() As subs

Const Projectname = "Heroes of saragone"

Public Sub Enterfunc(name, Optional args)
If Not Callset Then
    ReDim Callstack(0)
    ReDim Timinglog(0)
    Callset = True
End If

ub = UBound(Callstack) + 1
ReDim Preserve Callstack(ub)
Callstack(ub).name = name
If Not IsMissing(args) Then
    Callstack(ub).args = args
Else
    Callstack(ub).args = "No arguments given"
End If

Logstack name & vbCrLf & Callstack(ub).args
For x = 1 To UBound(Timinglog)
If UCase(Timinglog(x).name) = UCase(name) Then
    Callstack(ub).time = t
    Exit Sub
End If
Next x

uc = UBound(Timinglog) + 1
ReDim Preserve Timinglog(uc)

Timinglog(uc).name = name
Callstack(ub).time = Timer
End Sub

Private Sub Logstack(msg)
Dim nf As Integer
nf = FreeFile
Open Stacklog For Append As #nf
Print #nf, msg
Close #nf
End Sub

Public Sub Leave()
ub = UBound(Callstack)
Logstack "LEAVE"
Assert ub, "Leave: Stack underflow"

calltime = Timer - Callstack(ub).time
For x = 1 To UBound(Timinglog)
If UCase(Timinglog(x).name) = UCase(Callstack(ub).name) Then
    Timinglog(x).notimes = Timinglog(x).notimes + 1
    Timinglog(x).sumtime = Timinglog(x).sumtime + calltime
    Timinglog(x).time = Timinglog(x).sumtime / Timinglog(x).notimes
    
    ub = ub - 1
    ReDim Preserve Callstack(ub)
    Exit Sub
End If
Next x

uc = UBound(Timinglog) + 1
ReDim Preserve Timinglog(uc)
Timinglog(x).name = Callstack(ub).name

ub = ub - 1
ReDim Preserve Callstack(ub)
End Sub

Public Sub Stacktrace()
Dim nf As Integer
nf = FreeFile
Open Logfile For Append As #nf
Print #nf, "<b><font color='blue'>Stack trace</font></b><br>"
For x = 1 To UBound(Callstack)
Print #1, "<b>Name</b>: " & Callstack(x).name & "<br><b>Arguments</b>: " & Callstack(x).args & "<p><hr>"
Next x
Print #nf, "<b><font color='blue'>End of Stack trace</font></b>"
Close #nf
End Sub

Private Function delimhex(i)
Dim o As String
o = Hex(i)
o = String(2 - Len(o), "0") & o
delimhex = o
End Function

Public Sub Timestack()
Dim nf As Integer
Dim Ctime As Double
Dim Csum As Double

nf = FreeFile
Open Logfile For Append As #nf
Print #nf, "<b><font color='blue'>Timing trace</font></b><br>"
For x = 1 To UBound(Timinglog)
Ctime = (Timinglog(x).sumtime / Timinglog(x).notimes)
Csum = Csum + Ctime
Next x

Dim swp As subs
Do
DoEvents
B = 0
For x = 1 To UBound(Timinglog) - 1
Ctime = Timinglog(x).sumtime / Timinglog(x).notimes
ctme = Timinglog(x + 1).sumtime / Timinglog(x + 1).notimes
If (ctme > Ctime) Then
    swp = Timinglog(x)
    Timinglog(x) = Timinglog(x + 1)
    Timinglog(x + 1) = swp
    B = 1
End If
Next x
Loop Until B = 0

For x = 1 To UBound(Timinglog)
Ctime = Timinglog(x).sumtime / Timinglog(x).notimes

red = (Ctime / Csum) * 255
If red > 100 Then red = 255

blue = 255 - red

Col = delimhex(red) & "00" & delimhex(blue)

Print #nf, "<font color='" & Col & "'>" & Timinglog(x).name & " (" & Ctime & ") [" & (Ctime / Csum) * 100 & "%]</font><br>"
Next x
Print #nf, "<b><font color='blue'>End of Timing Stack trace</font></b>"
Close #nf
End Sub

Public Sub Debugbuild(Optional re)
If IsMissing(re) Then re = True 'This lets you decide if it is a debug build. Simply say Debugbuild and it'll start.
Setdebugbuild = re
End Sub

Public Function Getattentions() As String
Getattentions = Att
End Function

Public Function Geterrors() As String
Geterrors = Errors
End Function

Public Function Getwarnings() As String
Getwarnings = Warnings
End Function

Public Function Getasserts() As String
Getasserts = Asserterror
End Function

Public Sub Startdebug(Optional logf, Optional stackf, Optional purge As Boolean = True)
Setdebugbuild = True
Savefile = True


If fpath = "" Then fpath = App.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\" 'Find where we are

If IsMissing(logf) Then
    Logfile = fpath & "Logfile.html" 'The programmer didn't specify a parameter so use the defult
Else
    Logfile = logf 'Otherwise, use what the programmer asked for
End If

If IsMissing(stackf) Then
    Stacklog = fpath & "Stacklog.log"
Else
    Stacklog = stackf 'Set stack log
End If

If Dir(Stacklog) <> "" Then Kill Stacklog

Dim nf As Integer
nf = FreeFile
Open Stacklog For Output As nf
Close #nf

If purge Then
    If Dir(Logfile) <> "" Then Kill Logfile
End If

Touchfile Logfile 'Make files if there not already there

If Not programon Then Debuglog "Program started on " & Now
Debuglog "Debugging started" 'Start the log
End Sub

Private Sub Touchfile(filename)
Dim fileop As Integer
fileop = FreeFile
If Dir(filename) = "" Then 'If the file doesn't exist
    Open filename For Output As fileop 'Make it
    Print #fileop, "<html><head><title>" & Projectname & "</title></head><body bgcolor='#000000' text='#FFFFFF'><b><i><center><font size='6'>This is a logfile made for " & Projectname & " for debugging purposes</b></i></font><p><font size='5'><hr>"
    Close #fileop
End If

Open filename For Append As fileop 'Add a timestamp for it.
Print #fileop, ""
Print #fileop, "<h2>Debugging started on</h2> " & Now & "<p><hr>"
Close #fileop

End Sub

Public Sub Assert(Condition, Optional Errmsg, Optional Iswarning As Boolean, Optional Sucmsg)
Dim cond
If Not Setdebugbuild Then Exit Sub
On Error Resume Next
If VarType(Condition) = vbString Then
    cond = Len(Condition)
Else
    cond = Condition
End If

If cond = 0 Then 'Condition failed. Error
    If IsMissing(Errmsg) Then Errmsg = "Assert failed" 'Generic messages
    If Trim(Errmsg) = "" Then Errmsg = "Assert failed"
    
    If Iswarning Then 'Check if its an "assert warning"
        Debuglog Errmsg, 9
    Else
        Debuglog Errmsg, 10
        Stacktrace
        End
    End If
Else
    If Not IsMissing(Sucmsg) Then
        log "Assert passed: " & Sucmsg, "<font color='#00CC00'><b>Assert passed</b>: " & Sucmsg & "</font><p>"
    End If
End If
End Sub

Public Sub Er(msg) 'Simple functions for ease of use
If Not Setdebugbuild Then Exit Sub
Debuglog msg, 10
End
End Sub
Public Sub Warn(msg)
Debuglog msg, 9
End Sub

Public Sub success(msg)
log msg, "<font color='#00CC00'><b>Success</b>: " & msg & "</font><p>"
End Sub
Public Sub Debuglog(msg, Optional lvl)
If Not Setdebugbuild Then Exit Sub

Dim newfile As Integer
newfile = FreeFile

If IsMissing(lvl) Then 'If you don't have a level, then you simply make it an "Attention:" statement
    'Debug.Print "Attention :" & msg 'Tell the user
    Att = Att & msg & vbCrLf
    log "Attention :" & msg, "<font color=""#00CCFF""><b>Attention</b>: " & msg & "</font><p>"
    'If Not Savefile Then Exit Sub
    'Open Logfile For Append As #newfile 'Write it to the logfile
    'Print #newfile, "<font color=""#00CCFF""><b>Attention</b>: " & msg & "</font><p>"
    'Close #newfile
Else
    If (lvl < 9 Or lvl > 10) Then  'Its not an assert warning or error.
        If Not Savefile Then Exit Sub
        Errors = Errors & msg & vbCrLf
        log "Error level " & lvl & " :" & msg, "<font color='#FFCC66'><b>Error level</b> <i>" & lvl & "</i>: " & msg & "</font><p>"
        'Debug.Print "Error level " & lvl & " :" & msg 'Tell the user
        'Open Logfile For Append As #newfile
        'Print #newfile, "<font color='#FFCC66'><b>Error level</b> <i>" & lvl & "</i>: " & msg & "</font><p>"
        'Close #newfile
    ElseIf lvl = 9 Then 'Its an assert warning
        Warnings = Warnings & msg & vbCrLf
        log "Warning :" & msg, "<font color='#FFFF66' size='+3'><b>Warning</b>: " & msg & "<p></font>"
        'Debug.Print "Warning :" & msg
        'If Not Savefile Then Exit Sub
        'Open Logfile For Append As #newfile
        'Print #newfile, "<font color='#FFFF66' size='+3'><b>Warning</b>: " & msg & "<p></font>"
        'Close #newfile
    ElseIf lvl = 10 Then 'Its an assert error
        Asserterror = Asserterror & msg & vbCrLf
        log "Critical Error :" & msg, "<hr><b><font size='+5' color='#FF6600'><blink>Critical Error:</b></blink> " & msg & "</font><p><hr>"
        'Debug.Print "Critical Error :" & msg
        'If Not Savefile Then Exit Sub
        'Open Logfile For Append As #newfile
        'Print #newfile, "<hr><b><font size='+5' color='#FF6600'><blink>Critical Error:</b></blink> " & msg & "</font><p><hr>"
        'Close #newfile
    End If
End If
End Sub
Public Sub log(dmsg, Optional fmsg)
If IsMissing(fmsg) Then fmsg = dmsg
Debug.Print dmsg
If Not Savefile Then Exit Sub
Dim newfile As Integer
newfile = FreeFile
Open Logfile For Append As #newfile
Print #newfile, fmsg
Close #newfile
End Sub

